perm filename TREST.OLD[MSS,LCS] blob
sn#145076 filedate 1975-02-08 generic text, type T, neo UTF8
00100 C******* SUBRS TAIL, FERMTA, REST, BREP, EXCH, SORT2, NOZERO,
00150 C******* JDRAW,CENTR,LINX,UNPACK,ROFF,NOIR, KSIG, ALPHA
00200 SUBROUTINE TAIL(RJX,RA,RMINI)
00300 COMMON /STF/RSTFAC(8),RSTJ3
00400 COMMON /PLTR/IPLT,RHT,DIS
00500 DIMENSION ITAIL(16)
00600 DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
00700 1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
00710 CALL CENTER(RJY)
00800 Q=-1.
00900 IF(RA)Q=1.
00905 IF(IPLT)GO TO 2
00910 ITAIL(1)=10
01100 1 CALL JDRAW(ITAIL,RJX,RJY,RMINI,1.,Q)
01200 RETURN
01250 2 P=Q
01300 IF(RMINI.NE.RSTJ3)P=P*.6
01400 ITAIL(1)=16
01500 CALL FILLMS(12,ITAIL(5),RJX,RJY,ABS(P),P)
01600 C RA=-,STEM UP; RA=+, STEM DOWN.
01650 GO TO 1
01700 END
01800
01900 SUBROUTINE REST
02000 COMMON /STF/RSTFAC(8),RSTJ3/PLTR/IPLT,RHT,DIS
02100 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
02200 EQUIVALENCE(J5,JQ(3))
02300 DIMENSION LRST(3),IRST(47),MR(2),MF(2)
02400 DATA IRST/9,100000033,160033,160030, 30,32 ,160032 ,160031,
02600 1 31, 23,100000051,100038,32,110017,200050044, 32 ,50026,
02700 1 100038,50044,100110017,70018,50017,50015,60011, 10016,
02800 1 18, 20,10022,30023, 50023, 70022,110017,
02900 1 15,100030033, 40032, 80032,120035,150039,70014,200010037,
03000 1 30039, 50039, 70037, 70035, 50033, 30033,10035/
03100 1,LRST/1,10,33/,MR/18,8/,MF/15,40/
03150 C LRST = BEGINNING OF EACH REST, MR=FILLER WDCNT, MF=FILL START.
03200
03400 L=J5
03500 IF(L.GT.1)L=1
03600 IF(L)L=-1
03700 C L>3 WHEN SEVERAL TAILS ON REST
03800 CALL CENTER(CENTR)
03900 IF(J5.EQ.-2)CENTR=CENTR+9.4*RSTJ3
04000 CALL JDRAW(IRST(LRST(L+2)),R2,CENTR,RSTJ3,1.,1.)
04100 IF(J5.OR.IPLT.GE.0)RETURN
04200 L=L+1
04300 CALL FILLMS(MR(L),IRST(MF(L)),R2,CENTR,1.,1.)
04400 C WHY GO THROUGH NOTWRT??
04500 END
04600
04800 C READS DATA
06100 C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
06200 SUBROUTINE BREP(R2,RSTJ3)
06300 DIMENSION IREP(35)
06400 DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
06500 1,30015, 40015, 320043,100020037, 30038, 40038, 50037
06600 1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
06700 1,100270022,280021,290021,300022,300023,290024,280024,270023
06800 1,270022, 300022, 270023, 290023/
07000 CALL CENTER(R)
07100 CALL JDRAW(IREP,R2,R,RSTJ3,1.,1.)
07200 END
07300
07400 SUBROUTINE FERMTA(RINV)
07500 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
07600 COMMON /PLTR/IPLT,RHT,DIS
07700 COMMON /STF/RSTFAC(8),RSTJ3
07800 DIMENSION JFERM(45)
07900 DATA JFERM/24,310020003,10010010,20015,60017,110017,160015,
08000 1 190010,200003,170010,150012,120014,70014,30012,10010,
08100 1 10020003,100070007,80008,100008,110007,110006,100005,80005
08200 1 ,70006, 20,100081006, 80012, 90012, 91006, 110030002, 30008,
08300 1 70002,130008,170002, 200005, 200170002,141001,100005,130008,
08400 1 170002, 100070002, 41001, 5, 30008, 70002/
08410 IF(RINV.LT.17)GO TO 1
08420 JFERM(29)=16
08425 JFERM(35)=210005
08430 IF(RINV.NE.17)GO TO 2
08435 JFERM(29)=91006
08440 J=25
08450 GO TO 4
08460 2 JFERM(29)=16
08470 C FOR INVERTED MORDANT
08480 J=29
08485 4 RINV=1.
08490 GO TO 3
08500 1 J=1
08590 3 CALL JDRAW(JFERM(J),R2,CENTR,RSTJ3,1.,RINV)
08700 IF(IPLT.GE.0)RETURN
08710 IF(J.EQ.1)GO TO 5
08720 J=35
08730 JFERM(35)=10
08750 5 CALL FILLMS(JFERM(J),JFERM(J+1),R2,CENTR,1.,RINV)
08800 END
08900
09000 SUBROUTINE EXCH(X,Y)
09100 Z=X
09200 X=Y
09300 Y=Z
09400 END
09500 SUBROUTINE SORT2(RPOS,M)
09600 DIMENSION RPOS(2,200)
09700 L=2
09800 3 J=-1
09900 RX=RPOS(1,L-1)
10000 DO 2 K=L,M
10100 IF(RPOS(1,K).GE.RX)GO TO 2
10200 RX=RPOS(1,K)
10300 C WHY WERE ALL THE RX'S JX ????? 9/6/73
10400 J=K
10500 2 CONTINUE
10600 IF(J)GO TO 4
10700 K=L-1
10800 CALL EXCH(RPOS(1,K),RPOS(1,J))
10900 CALL EXCH(RPOS(2,K),RPOS(2,J))
11000 4 L=L+1
11100 IF(L.LE.M)GO TO 3
11200 END
11300
11400 SUBROUTINE NOZERO(X)
11500 IF(X.EQ.0)X=1
11600 END
11700
11800 SUBROUTINE PNUM
11900 COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),J3,J4,J5,
12000 1 J6,J7,J10J,IPUNC,SIZ,RXX,RX,JQ(10)
12100 COMMON /STF/RSTFAC(-3/4),RSTJ3
12200 COMMON /NU/NUMQ(44),RNUMS(327),RACCI(22),NACCI(3)
15000 CALL CENTX
15100 J10J=J6
15200 CALL NOZERO(R5)
15250 SIZ=R5*RSTJ3
15300 IPUNC=0
15400 IF(J10J.LT.44)GO TO 451
15500 IPUNC=J10J
15600 IF(J10J.EQ.44)J10J=38
15700 IF(J10J.GE.45)J10J=36
15800 IF(J6.NE.46)GO TO 451
15900 RXX=4
16000 CALL RJBX(-RXX)
16100 RX=16
16200 CENTR=CENTR+RX*SIZ
16300 CC51 RX=RDIS*RSTJ3
16400 451 IX=NUMQ(J10J+1)
16500 C IX=END # OF ITEM
16600 C IX+1=1ST PART OF ITEM
16700 CALL RDRAW(IX+1,RNUMS(IX),RNUMS,SIZ,R2,CENTR+RSTJ3*3.,SIZ)
16800 IF(IPUNC.EQ.0)RETURN
16900 IF(IPUNC.NE.46)GO TO 351
17000 CALL RJBX(SIZ*2.*RXX)
17100 C FOR "
17200 651 IPUNC=0
17300 GO TO 451
17400 351 RXX=11
17500 C FOR : AND ;
17600 CENTR=CENTR+RXX*SIZ
17700 J10J=38
17800 GO TO 651
17900 END
00100 C****** FOR LISTS OF LETTERS, ETC. AND TRILL *******
00200 SUBROUTINE ALPHA
00300 COMMON /PLTR/IPLT,RHT,DIS /FONT/JFONT
00400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
00500 EQUIVALENCE(J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
00600 1(R8,RJQ(6)),(NRJ,RJQ(8)),(JX,JQ(11)),(RSX,JQ(12)),
00700 1(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
00800 1,(J6,JQ(4)),(R7,RJQ(5)),(R4,RJQ(2)),(IFNT,JQ(13)),
00810 1(NR,JQ(14)),(RSP,JQ(15)),(RY,JQ(16)),(RX,JQ(17)),(RZ,JQ(18)),(RW
00820 1,JQ(19)),(RB,JQ(20)),(R,RJQ(20)),(FILL,RJQ(19))
00825 1,(JTR,RJQ(17)),(RF,RJQ(15)),(JJ2,RJQ(14))
00900 COMMON/STF/RSTFAC(8),RSTJ3
01000 DATA R4X/-2.1/,IFONT/1/, NR/'PRIM0'/
01100
01200 IF(JA.EQ.20)GO TO 20
01210 JTR=99
01400 C PRIMITIVE IS DEFAULT FONT. #=SET BACK TO PRIM.
01500 C ONLY 11 LETTERS WITHOUT FONT RESET.
01700 54 R=19.7*R5*RSTJ3
01800 RB=J2
01810 RW=R4
01900 J9=0
02000 C J9=0 AVOIDS ROTATION IN 'CLEFS'
02300 DO 50 KA=4,6
02400 JY=RJQ(KA)*100.+.2
02500 JX=1000000
02600 DO 53 LA=1,4
02700 J6=JY/JX
02701 J6X=J6
02702 R2=J2
02705 IF(J6.EQ.99)GO TO 55
02707 C NO MORE IN THIS WD.
02710 IF(J6.LT.50)GO TO 1
02800 GO TO(2,3,1,4,5),J6-49
02900 C SWITCHES FOR DIFF. FONTS. (55 MAKES ')
02925 J6=36
02930 R4=R4+2.9
02937 C WILL MAKE '.
02950 GO TO 1
03000 2 NR='BDR40'
03100 C &=NON-ITALICS -- JFONT IS TEMPORARY SWITCH 5/74
03150 GO TO 8
03200 3 NR='BDI40'
03300 C @=51=ITALICS
03350 8 IF(IFNT.EQ.0)IFNT=-1
03400 GO TO 11
03500 4 FILL=-2
03600 GO TO 11
03700 5 FILL=0
03800 GO TO 11
03900 1 CALL SPACER(J6,IFNT,RB,R)
03950 IF(J6-47)7,6,11
07300 7 IF(JFONT.EQ.0.AND.IPLT.GE.0)GO TO 30
07400 C JFONT=0 FOR FIXED WIDTH OF FONTS. = AND ONLY DPYS PRIMITIVE.
07600 J5=J6
07610 IF(IFNT.EQ.0)GO TO 30
07650 IF(J6.GE.36)GO TO 30
07675 C PUNCTUATION AND SPACE.
07700 IF(IFNT.AND.J5.GT.9)J5=J5+26
07800 RX=R6
07900 R6=R5*.28
08000 C .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
08100 RY=R7
08200 R7=R6
08300 RZ=R8
08500 R4=R4+R4X
08550 C SHIFTS DOWN ??? WHY NOT GET RID OF THIS.??
08600 R8=FILL
08700 NRJ=NR
08800 C GETS RIGHT FILE
08900 JA=11
09025 CC R2=J2
09050 CALL CLEFS
09100 R6=RX
09200 R7=RY
09300 R8=RZ
09500 C PUTS BACK RIGHT STUFF
09700 GO TO 6
09800
09950 30 J7=0
10000 CALL PNUM
10100 C 47=BLANK (WAS 99)
10500 6 J2=ROFF(RB)
10600 R4=RW
11000 11 JY=JY-J6X*JX
11100 C TO GET NEXT NUM OUT OF JY
11200 53 JX=JX/100
11300 50 CONTINUE
11310 55 IF(JTR.EQ.99)RETURN
11400 GO TO 52
11500
11550
11600 C FOR TRILLS
11800 C RTR SAVES R2(WHICH GETS CLOBBERED WHEN 'TR' IS WRITTEN.)
11900 C 20, POS1, STF, NT#, SIZE, POS2, X IF X=1 THEN NO WAVEY LINE
11910 20 CALL NOZERO(R5)
11955 R10=R5
12000 R5=.8*R5
12050 J2=J2+6*RSTJ3
12100 RF=R6
12200 JJ2=J2
12300 R6=495129.27
12400 C %@tr LWR CASE, ITAL. TR
12500 R7=999999.99
12600 R8=R7
12700 JTR=J7
12800 GO TO 54
13000 52 IF(JTR.NE.0)RETURN
13200 C RETURN IF NO WAVY LINE IS NEEDED
13210 J2=JJ2+20.*RSTJ3*R10
13300 JA=4
13500 J7=-2
13600 C J7 IS SWITCH TO DRAW WIGGLE
13650 R6=RF
13700 R5=R4+.7*R10
13710 R8=.9*R10
13735 C R10 IS SIZE (P5)
13750 J10=0
13760 IF(IPLT)J10=1
13800 CALL ITMSUB
13860 C SINGLE WIGGLE ON DPY, DOUBLE ON PLOTTER.
13900 END
14000
14100
14200 SUBROUTINE SPACER(J6,IFNT,RB,R)
14300 C SPACES ALPHABET ITEMS.
14400 DATA RS/1.08/,RSPC/1./,RLWR/.96/
15200 C JUMP TO USE PRIMITIVE ALPHABET.
15300 IF((J6.GT.9.AND.J6.LT.36).OR.J6.GT.47)GO TO 10
15400 C NEXT FOR NUMBERS, SPACE AND PUNCTUATION.
15500 RSX=RSPC
15550 IF(IFNT)RSX=.9
15600 GO TO 3
15700 10 IF(J6.LT.47)GO TO 5
15800 IF(J6.EQ.52)GO TO 14
15900 IF(J6.EQ.48)IFNT=1
16000 IF(J6.EQ.49)IFNT=-1
16050 IF(J6.GE.55)GO TO 5
16075 C PUNCT. WILL EXPAND ABOVE 54.
16100 RETURN
16200 14 IFNT=0
16300 C #=52=PRIMITIVE
16400 JA=5
16600 RETURN
17000 5 RSX=RS
17200 IF(IFNT)RSX=RLWR
17250 C FOR LOWER CASE SPACING. (96%)
17400 IF(J6.EQ.22.OR.J6.EQ.32)RSX=RSX*1.12
17500 C FOR M AND W
17700 3 IF(J6.EQ.1.OR.J6.EQ.18.OR.J6.EQ.19.OR.J6.GE.36)GO TO 21
17705 C FOR 1,I AND J
17710 IF(IFNT.GE.0)GO TO 4
17720 C NEXT FOR LOWER CASE ONLY.
17730 IF(J6.NE.15.AND.J6.NE.19.AND.J6.NE.21.AND.J6.NE.29)GO TO 4
17735 21 IF(J6.NE.47)RSX=RSX*.68
17750 C FOR F,I,J,L,T
17800 4 RB=RB+R*RSX
17900 END
18000
19000
19100 SUBROUTINE JDRAW(M,R2,CENTR,RSTJ3,RX,RY)
19200 COMMON/LL/LL
19300 DIMENSION M(1)
19400 RC=RX*RSTJ3
19500 RD=RY*RSTJ3
19600 DO 2 K=2,M(1)
19700 CALL UNPACK(IA,IB,M(K))
19800 2 CALL LINES(FLOAT(IA)*RC+R2,FLOAT(IB)*RD+CENTR,LL)
19900 END
20000
20100 SUBROUTINE CENTER(CNTR)
20200 C TO CENTER ITEMS CREATED WITH DRAWING PROG.
20300 COMMON /STF/RSTFAC(8),RSTJ3
20400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
20500 COMMON/POSI/STF(8),JJ2,POS
20600 EQUIVALENCE (R4,RJQ(2))
20700 CNTR=POS+(2+AMOD(R4,100.)*7)*RSTJ3
20800 END
20900
21000 SUBROUTINE LINX(A,B,C,D)
21100 C SAVES SPACE FOR SINGLE LINES.
21200 CALL LINES(A,B,3)
21300 CALL LINES(C,D,2)
21400 END
21500
21600 SUBROUTINE UNPACK(M,N,I)
21700 COMMON/LL/L
21800 C L IS FOR VIS. OR INVIS. LINES.
21900 N=I
22000 L=2
22100 M=N/100000000
22200 IF(M.EQ.0)GO TO 2
22300 L=3
22400 N=N-100000000*M
22500 2 M=N/10000
22600 N=MOD(N,10000)
22700 IF(M.GT.1000)M=1000-M
22800 IF(N.GT.1000)N=1000-N
22900 END
23000
23100 FUNCTION ROFF(R)
23200 S=.5
23300 IF(R)S=-S
23400 ROFF=R+S
23500 RETURN
23600 END
23700
23800
23900 C************** NOIR, RJBX, CENTX ***************
24000 SUBROUTINE NOIR(RMINI)
24100 C BLACKS IN NOTES
24200 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(12),B,C,KC,D,N,JY,M,L
24300 COMMON/PLTR/IPLT,RHT,DIS /XRN/IRN(4000)
24400 EQUIVALENCE (PRE,IRN(1))
24500 DATA BL/7.5/,BH/6.7/
24600 C ADJUST BH AND FL FOR HEIGHT OF NOTE AND 'WIDTH'
24700 IPOS=ROFF(R2*DIS)
24800 CC IF(RMINI.LT..9)IPOS=IPOS+1
24900 JPOS=ROFF(CENTR*RHT)
25000 IF(-RMINI.EQ.PRE)GO TO 10
25100 PRE=-RMINI
25200 CC D=.25*RMINI
25250 D=.25
25300 B=BH*RMINI*RHT
25400 E=RMINI*DIS
25500 A=BL*E
25600 IC=A
25700 A=A*A
26200 E=-B/4.
26300 K=B
26400 B=B*B
26500 C USES EQUATION FOR ELLIPSE
26600 N=1
26700 NX=2
26800 6 DO 1 J=-K,K
26900 Y=J*J
27000 X=SQRT(A-(A*Y)/B)
27100 L=E-X
27200 M=X+E
27300 C THE TWO SIDES OF THE LINE
27400 IF(N)CALL EXCH(L,M)
27500 IRN(NX)=L
27600 IRN(NX+1)=M
27700 C C IS VERTICLE POS.
27800 NX=NX+2
27900 E=E+D
28000 C E IS TO TILT IT.
28100 1 N=-N
28200 10 CALL PLOT(IPOS+3,JPOS,3)
28300 N=2
28400 C 1ST LOC. OF ARRAY HAS "PRE"
28500 L=IPOS+IC
28600 DO 11 M=-K,K
28700 J=M+JPOS
28800 CALL PLOT(L+IRN(N),J,2)
28900 CALL PLOT(L+IRN(N+1),J,2)
29000 11 N=N+2
29100 END
29200
32200 SUBROUTINE RJBX(R)
32300 COMMON R2,RJQ(43)/STF/RSTFAC(8),RSTJ3
32400 R2=R2+R*RSTJ3
32500 END
32600
32700 SUBROUTINE CENTX
32800 COMMON A,B,CENTR,D,E,R4,R(38) /STF/RSTFAC(8),RSTJ3
32900 1 /POSI/STFF(8),JJ2,POS
33000 CENTR=POS-18.*RSTJ3+AMOD(R4,100.0)*RSTJ3*7.
33100 END
33200
33300 C ******* 7, POS, STF, NUM OF SHARPS OR FLATS (+ OR -), CLEF, HGT
33400 C ( CLEF = TREB,0 BASS,1 ALT,2 TEN,3 )
33500 SUBROUTINE KSIG
33600 C FOR KEY SIGNATURES AND ACCENTS, ETC. (IN 'SCORE')
33700 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(17),T,S,Z/STF/RSTFAC(-3/4),RSTJ3
33800 EQUIVALENCE (R4,RJQ(2)),(J4,JQ(2)),(J5,JQ(3)),(J6,JQ(4))
33900
34000 JA=6
34100 C USES THIS KEY NUM IN NOTWRT
34200 C COUNTER
34300 IZ=IABS(J4)
34400 C NUMBER OF CALLS ON NOTWRT
34500 C THE CLEF NUM. IT GETS WIPED OUT IN NOTWRT.
34600 JW=1
34700 IF(J4.GT.0)JW=2
34800 C THE CODE FOR FLAT OR SHARP
34900 5333 CLEF=-(J5+1)
35000 C CLEF #S ARE CHNGD TO -1,-2,-3,-4 (TREB.,BA.,ALT.,TEN.)
35100 C CLEF NOW SET IN MAIN PROG.
35200 C IF NO CLEF GIVEN, TREBLE IS USED.
35300 T=10.
35400 IF(CLEF.LT.-2.)T=11.
35500 S=CLEF+4.
35600 IF(CLEF.EQ.-4)S=-1.
35700 IF(J4.LT.0)GO TO 253
35800 W=-3.
35900 YY=4.
36000 Z=11.
36100 C SHARPS
36200 GO TO 353
36300 253 W=3.
36400 YY=-4.
36500 Z=7.
36600 C FLATS
36700 353 N=1
36800 RX=J2
36900 RA=0
37000 C RA IS AMOUNT TO BE ADDED TO ORIGINAL POS.
37100 DO 553 KA=1,IZ
37200 J5=JW
37300 R2=RX+RA
37400 RA=RA+13.*RSTJ3
37500 C MOVES OVER FOR NEXT ACCI.
37600 RD=Z
37700 R4=Z
37800 IF(CLEF.NE.-1.)GO TO 7
37900 IF(R4.GT.12.)R4=R4-7.
38000 GO TO 9
38100 7 R4=R4-S
38200 IF(R4.GT.T)R4=R4-7.
38300 C ABOVE ARRANGES VERT. POS OF ACCIS.
38400 9 J4=R4
38500 C FOR VERT. POS. IN 'DRWNT' (WHEN PLOTTING.)
38600 CALL CENTX
38700 CALL NOTWRT
38800 Z=RD+W
38900 IF(N)Z=RD+YY
39000 553 N=-N
39100 END